home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyFetchSuffix.p < prev    next >
Encoding:
Text File  |  1993-12-23  |  3.4 KB  |  146 lines  |  [TEXT/PJMM]
  1. unit MyFetchSuffix;
  2.  
  3. { Thanks to Jim Matthews for allowing me to read his Fetch preference file }
  4.  
  5. interface
  6.  
  7.     function FetchSuffixInfo (name: str255; var ftype, fcreator: OSType; var binary, binhex: boolean): boolean;
  8.     function IsExtension (name, ext: str255): boolean;
  9.     function GetTextCreator: OSType;
  10.  
  11. implementation
  12.  
  13.     uses
  14.         Folders;
  15.  
  16.     const
  17.         SuffixResType = 'SUFX';
  18.         SuffixResID = 1;
  19.         old_fetch_prefs_name = 'Fetch Preferences';
  20.         new_fetch_prefs_name = 'Fetch Prefs'; { changed to avoid Aldus Prefs I assume }
  21.  
  22. { Format: }
  23. { repeat }
  24. {    type:OSType }
  25. {    creator:OSType }
  26. {    binary:two byte boolean }
  27. {    binhex: two byte boolean }
  28. {    extension:cstring }
  29. {    description:cstring }
  30. { until end of resource }
  31.  
  32.     type
  33.         formatRecord = record
  34.                 ftype: OSType;
  35.                 fcreator: OSType;
  36.                 binary: integer;
  37.                 binhex: integer;
  38.                 extension: str255;
  39.                 description: str255;
  40.             end;
  41.  
  42.     function GetTextCreator: OSType;
  43.         var
  44.             ftype, fcreator: OSType;
  45.             binary, binhex: boolean;
  46.     begin
  47.         if not FetchSuffixInfo('.txt', ftype, fcreator, binary, binhex) then
  48.             if not FetchSuffixInfo('.text', ftype, fcreator, binary, binhex) then
  49.                 fcreator := 'R*ch';
  50.         GetTextCreator := fcreator;
  51.     end;
  52.  
  53.     function IsExtension (name, ext: str255): boolean;
  54.     begin
  55.         IsExtension := IUEqualString(copy(name, length(name) - length(ext) + 1, 255), ext) = 0;
  56.     end;
  57.  
  58.     function FetchSuffixInfo (name: str255; var ftype, fcreator: OSType; var binary, binhex: boolean): boolean;
  59.         var
  60.             p: ptr;
  61.             left: longInt;
  62.             found: boolean;
  63.  
  64.         procedure CheckExt (ext: str255; ft, fc: OSType; bin, hex: boolean);
  65.         begin
  66.             if IsExtension(name, ext) then begin
  67.                 found := true;
  68.                 ftype := ft;
  69.                 fcreator := fc;
  70.                 binary := bin;
  71.                 binhex := hex;
  72.             end;
  73.         end;
  74.  
  75.         procedure ReadEntry;
  76.             procedure ReadString (var s: str255);
  77.                 var
  78.                     q: ptr;
  79.                     len: longInt;
  80.             begin
  81.                 len := 0;
  82.                 while p^ <> 0 do begin
  83.                     len := len + 1;
  84.                     if len <= 255 then
  85.                         s[len] := chr(p^);
  86.                     p := ptr(ord(p) + 1);
  87.                 end;
  88.                 p := ptr(ord(p) + 1);
  89.                 left := left - len - 1;
  90.                 if len > 255 then
  91.                     len := 255;
  92.                 s[0] := chr(len);
  93.             end;
  94.             var
  95.                 ext, desc: str255;
  96.                 fr: formatRecord;
  97.         begin
  98.             BlockMove(p, @fr, 12);
  99.             p := ptr(ord(p) + 12);
  100.             left := left - 12;
  101.             ReadString(ext);
  102.             ReadString(desc);
  103.             CheckExt(ext, fr.ftype, fr.fcreator, fr.binary <> 0, fr.binhex <> 0);
  104.         end;
  105.  
  106.         var
  107.             res: integer;
  108.             h: handle;
  109.             fs: FSSpec;
  110.             junk: OSErr;
  111.             goodenough: boolean;
  112.     begin
  113.         ftype := 'BINA';
  114.         fcreator := 'R*ch';
  115.         binary := true;
  116.         binhex := false;
  117.         found := false;
  118.         CheckExt('.hqx', 'TEXT', 'SITx', false, true);
  119.         CheckExt('.txt', 'TEXT', 'R*ch', false, false);
  120.         CheckExt('.sit', 'SITD', 'SITx', true, false);
  121.         CheckExt('.cpt', 'CPCT', 'SITx', true, false);
  122.         goodenough := found;
  123.         found := false;
  124.         junk := FindFolder(kOnSystemDisk, kPreferencesFolderType, true, fs.vRefNum, fs.parID);
  125.         fs.name := new_fetch_prefs_name;
  126.         res := HOpenResFile(fs.vRefNum, fs.parID, fs.name, fsRdPerm);
  127.         if res = -1 then begin
  128.             fs.name := old_fetch_prefs_name;
  129.             res := HOpenResFile(fs.vRefNum, fs.parID, fs.name, fsRdPerm);
  130.         end;
  131.         if res <> -1 then begin
  132.             h := Get1Resource(SuffixResType, SuffixResID);
  133.             if h <> nil then begin
  134.                 HLock(h); { Prob not necessary, but who cares }
  135.                 p := h^;
  136.                 left := GetHandleSize(h);
  137.                 while (left > 12) and not found do begin
  138.                     ReadEntry;
  139.                 end;
  140.             end;
  141.             CloseResFile(res);
  142.         end;
  143.         FetchSuffixInfo := found or goodenough;
  144.     end;
  145.  
  146. end.